home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp16.arc / XLMATH.C < prev    next >
Text File  |  1985-12-21  |  11KB  |  527 lines
  1. /* xlmath - xlisp builtin arithmetic functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. #include <fmath.h>
  10. overlay "math"
  11. #else
  12. #include <math.h>
  13. #endif
  14.  
  15. /* external variables */
  16. extern NODE *true;
  17.  
  18. /* forward declarations */
  19. FORWARD NODE *unary();
  20. FORWARD NODE *binary();
  21. FORWARD NODE *predicate();
  22. FORWARD NODE *compare();
  23.  
  24. /* xadd - builtin function for addition */
  25. NODE *xadd(args)
  26.   NODE *args;
  27. {
  28.     return (binary(args,'+'));
  29. }
  30.  
  31. /* xsub - builtin function for subtraction */
  32. NODE *xsub(args)
  33.   NODE *args;
  34. {
  35.     return (binary(args,'-'));
  36. }
  37.  
  38. /* xmul - builtin function for multiplication */
  39. NODE *xmul(args)
  40.   NODE *args;
  41. {
  42.     return (binary(args,'*'));
  43. }
  44.  
  45. /* xdiv - builtin function for division */
  46. NODE *xdiv(args)
  47.   NODE *args;
  48. {
  49.     return (binary(args,'/'));
  50. }
  51.  
  52. /* xrem - builtin function for remainder */
  53. NODE *xrem(args)
  54.   NODE *args;
  55. {
  56.     return (binary(args,'%'));
  57. }
  58.  
  59. /* xmin - builtin function for minimum */
  60. NODE *xmin(args)
  61.   NODE *args;
  62. {
  63.     return (binary(args,'m'));
  64. }
  65.  
  66. /* xmax - builtin function for maximum */
  67. NODE *xmax(args)
  68.   NODE *args;
  69. {
  70.     return (binary(args,'M'));
  71. }
  72.  
  73. /* xexpt - built-in function 'expt' */
  74. NODE *xexpt(args)
  75.   NODE *args;
  76. {
  77.     return (binary(args,'E'));
  78. }
  79.  
  80. /* xbitand - builtin function for bitwise and */
  81. NODE *xbitand(args)
  82.   NODE *args;
  83. {
  84.     return (binary(args,'&'));
  85. }
  86.  
  87. /* xbitior - builtin function for bitwise inclusive or */
  88. NODE *xbitior(args)
  89.   NODE *args;
  90. {
  91.     return (binary(args,'|'));
  92. }
  93.  
  94. /* xbitxor - builtin function for bitwise exclusive or */
  95. NODE *xbitxor(args)
  96.   NODE *args;
  97. {
  98.     return (binary(args,'^'));
  99. }
  100.  
  101. /* binary - handle binary operations */
  102. LOCAL NODE *binary(args,fcn)
  103.   NODE *args; int fcn;
  104. {
  105.     FIXNUM ival,iarg;
  106.     FLONUM fval,farg;
  107.     NODE *arg;
  108.     int imode;
  109.  
  110.     /* get the first argument */
  111.     arg = xlarg(&args);
  112.  
  113.     /* set the type of the first argument */
  114.     if (fixp(arg)) {
  115.     ival = getfixnum(arg);
  116.     imode = TRUE;
  117.     }
  118.     else if (floatp(arg)) {
  119.     fval = getflonum(arg);
  120.     imode = FALSE;
  121.     }
  122.     else
  123.     xlerror("bad argument type",arg);
  124.  
  125.     /* treat '-' with a single argument as a special case */
  126.     if (fcn == '-' && args == NIL)
  127.     if (imode)
  128.         ival = -ival;
  129.     else
  130.         fval = -fval;
  131.  
  132.     /* handle each remaining argument */
  133.     while (args) {
  134.  
  135.     /* get the next argument */
  136.     arg = xlarg(&args);
  137.  
  138.     /* check its type */
  139.     if (fixp(arg))
  140.         if (imode) iarg = getfixnum(arg);
  141.         else farg = (FLONUM)getfixnum(arg);
  142.     else if (floatp(arg))
  143.         if (imode) { fval = (FLONUM)ival; farg = getflonum(arg); imode = FALSE; }
  144.         else farg = getflonum(arg);
  145.     else
  146.         xlerror("bad argument type",arg);
  147.  
  148.     /* accumulate the result value */
  149.     if (imode)
  150.         switch (fcn) {
  151.         case '+':    ival += iarg; break;
  152.         case '-':    ival -= iarg; break;
  153.         case '*':    ival *= iarg; break;
  154.         case '/':    checkizero(iarg); ival /= iarg; break;
  155.         case '%':    checkizero(iarg); ival %= iarg; break;
  156.         case 'M':    if (iarg > ival) ival = iarg; break;
  157.         case 'm':    if (iarg < ival) ival = iarg; break;
  158.         case '&':    ival &= iarg; break;
  159.         case '|':    ival |= iarg; break;
  160.         case '^':    ival ^= iarg; break;
  161.         default:    badiop();
  162.         }
  163.     else
  164.         switch (fcn) {
  165.         case '+':    fval += farg; break;
  166.         case '-':    fval -= farg; break;
  167.         case '*':    fval *= farg; break;
  168.         case '/':    checkfzero(farg); fval /= farg; break;
  169.         case 'M':    if (farg > fval) fval = farg; break;
  170.         case 'm':    if (farg < fval) fval = farg; break;
  171.         case 'E':    fval = pow(fval,farg); break;
  172.         default:    badfop();
  173.         }
  174.     }
  175.  
  176.     /* return the result */
  177.     return (imode ? cvfixnum(ival) : cvflonum(fval));
  178. }
  179.  
  180. /* checkizero - check for integer division by zero */
  181. checkizero(iarg)
  182.   FIXNUM iarg;
  183. {
  184.     if (iarg == 0)
  185.     xlfail("division by zero");
  186. }
  187.  
  188. /* checkfzero - check for floating point division by zero */
  189. checkfzero(farg)
  190.   FLONUM farg;
  191. {
  192.     if (farg == 0.0)
  193.     xlfail("division by zero");
  194. }
  195.  
  196. /* checkfneg - check for square root of a negative number */
  197. checkfneg(farg)
  198.   FLONUM farg;
  199. {
  200.     if (farg < 0.0)
  201.     xlfail("square root of a negative number");
  202. }
  203.  
  204. /* xbitnot - bitwise not */
  205. NODE *xbitnot(args)
  206.   NODE *args;
  207. {
  208.     return (unary(args,'~'));
  209. }
  210.  
  211. /* xabs - builtin function for absolute value */
  212. NODE *xabs(args)
  213.   NODE *args;
  214. {
  215.     return (unary(args,'A'));
  216. }
  217.  
  218. /* xadd1 - builtin function for adding one */
  219. NODE *xadd1(args)
  220.   NODE *args;
  221. {
  222.     return (unary(args,'+'));
  223. }
  224.  
  225. /* xsub1 - builtin function for subtracting one */
  226. NODE *xsub1(args)
  227.   NODE *args;
  228. {
  229.     return (unary(args,'-'));
  230. }
  231.  
  232. /* xsin - built-in function 'sin' */
  233. NODE *xsin(args)
  234.   NODE *args;
  235. {
  236.     return (unary(args,'S'));
  237. }
  238.  
  239. /* xcos - built-in function 'cos' */
  240. NODE *xcos(args)
  241.   NODE *args;
  242. {
  243.     return (unary(args,'C'));
  244. }
  245.  
  246. /* xtan - built-in function 'tan' */
  247. NODE *xtan(args)
  248.   NODE *args;
  249. {
  250.     return (unary(args,'T'));
  251. }
  252.  
  253. /* xexp - built-in function 'exp' */
  254. NODE *xexp(args)
  255.   NODE *args;
  256. {
  257.     return (unary(args,'E'));
  258. }
  259.  
  260. /* xsqrt - built-in function 'sqrt' */
  261. NODE *xsqrt(args)
  262.   NODE *args;
  263. {
  264.     return (unary(args,'R'));
  265. }
  266.  
  267. /* xfix - built-in function 'fix' */
  268. NODE *xfix(args)
  269.   NODE *args;
  270. {
  271.     return (unary(args,'I'));
  272. }
  273.  
  274. /* xfloat - built-in function 'float' */
  275. NODE *xfloat(args)
  276.   NODE *args;
  277. {
  278.     return (unary(args,'F'));
  279. }
  280.  
  281. /* xrand - built-in function 'random' */
  282. NODE *xrand(args)
  283.   NODE *args;
  284. {
  285.     return (unary(args,'R'));
  286. }
  287.  
  288. /* unary - handle unary operations */
  289. LOCAL NODE *unary(args,fcn)
  290.   NODE *args; int fcn;
  291. {
  292.     FLONUM fval;
  293.     FIXNUM ival;
  294.     NODE *arg;
  295.  
  296.     /* get the argument */
  297.     arg = xlarg(&args);
  298.     xllastarg(args);
  299.  
  300.     /* check its type */
  301.     if (fixp(arg)) {
  302.     ival = getfixnum(arg);
  303.     switch (fcn) {
  304.     case '~':    ival = ~ival; break;
  305.     case 'A':    ival = abs(ival); break;
  306.     case '+':    ival++; break;
  307.     case '-':    ival--; break;
  308.     case 'I':    break;
  309.     case 'F':    return (cvflonum((FLONUM)ival));
  310.     case 'R':    ival = (FIXNUM)osrand((int)ival); break;
  311.     default:    badiop();
  312.     }
  313.     return (cvfixnum(ival));
  314.     }
  315.     else if (floatp(arg)) {
  316.     fval = getflonum(arg);
  317.     switch (fcn) {
  318.     case 'A':    fval = fabs(fval); break;
  319.     case '+':    fval += 1.0; break;
  320.     case '-':    fval -= 1.0; break;
  321.     case 'S':    fval = sin(fval); break;
  322.     case 'C':    fval = cos(fval); break;
  323.     case 'T':    fval = tan(fval); break;
  324.     case 'E':    fval = exp(fval); break;
  325.     case 'R':    checkfneg(fval); fval = sqrt(fval); break;
  326.     case 'I':    return (cvfixnum((FIXNUM)fval));
  327.     case 'F':    break;
  328.     default:    badfop();
  329.     }
  330.     return (cvflonum(fval));
  331.     }
  332.     else
  333.     xlerror("bad argument type",arg);
  334. }
  335.  
  336. /* xminusp - is this number negative? */
  337. NODE *xminusp(args)
  338.   NODE *args;
  339. {
  340.     return (predicate(args,'-'));
  341. }
  342.  
  343. /* xzerop - is this number zero? */
  344. NODE *xzerop(args)
  345.   NODE *args;
  346. {
  347.     return (predicate(args,'Z'));
  348. }
  349.  
  350. /* xplusp - is this number positive? */
  351. NODE *xplusp(args)
  352.   NODE *args;
  353. {
  354.     return (predicate(args,'+'));
  355. }
  356.  
  357. /* xevenp - is this number even? */
  358. NODE *xevenp(args)
  359.   NODE *args;
  360. {
  361.     return (predicate(args,'E'));
  362. }
  363.  
  364. /* xoddp - is this number odd? */
  365. NODE *xoddp(args)
  366.   NODE *args;
  367. {
  368.     return (predicate(args,'O'));
  369. }
  370.  
  371. /* predicate - handle a predicate function */
  372. LOCAL NODE *predicate(args,fcn)
  373.   NODE *args; int fcn;
  374. {
  375.     FLONUM fval;
  376.     FIXNUM ival;
  377.     NODE *arg;
  378.  
  379.     /* get the argument */
  380.     arg = xlarg(&args);
  381.     xllastarg(args);
  382.  
  383.     /* check the argument type */
  384.     if (fixp(arg)) {
  385.     ival = getfixnum(arg);
  386.     switch (fcn) {
  387.     case '-':    ival = (ival < 0); break;
  388.     case 'Z':    ival = (ival == 0); break;
  389.     case '+':    ival = (ival > 0); break;
  390.     case 'E':    ival = ((ival & 1) == 0); break;
  391.     case 'O':    ival = ((ival & 1) != 0); break;
  392.     default:    badiop();
  393.     }
  394.     }
  395.     else if (floatp(arg)) {
  396.     fval = getflonum(arg);
  397.     switch (fcn) {
  398.     case '-':    ival = (fval < 0); break;
  399.     case 'Z':    ival = (fval == 0); break;
  400.     case '+':    ival = (fval > 0); break;
  401.     default:    badfop();
  402.     }
  403.     }
  404.     else
  405.     xlerror("bad argument type",arg);
  406.  
  407.     /* return the result value */
  408.     return (ival ? true : NIL);
  409. }
  410.  
  411. /* xlss - builtin function for < */
  412. NODE *xlss(args)
  413.   NODE *args;
  414. {
  415.     return (compare(args,'<'));
  416. }
  417.  
  418. /* xleq - builtin function for <= */
  419. NODE *xleq(args)
  420.   NODE *args;
  421. {
  422.     return (compare(args,'L'));
  423. }
  424.  
  425. /* equ - builtin function for = */
  426. NODE *xequ(args)
  427.   NODE *args;
  428. {
  429.     return (compare(args,'='));
  430. }
  431.  
  432. /* xneq - builtin function for /= */
  433. NODE *xneq(args)
  434.   NODE *args;
  435. {
  436.     return (compare(args,'#'));
  437. }
  438.  
  439. /* xgeq - builtin function for >= */
  440. NODE *xgeq(args)
  441.   NODE *args;
  442. {
  443.     return (compare(args,'G'));
  444. }
  445.  
  446. /* xgtr - builtin function for > */
  447. NODE *xgtr(args)
  448.   NODE *args;
  449. {
  450.     return (compare(args,'>'));
  451. }
  452.  
  453. /* compare - common compare function */
  454. LOCAL NODE *compare(args,fcn)
  455.   NODE *args; int fcn;
  456. {
  457.     NODE *arg1,*arg2;
  458.     FIXNUM icmp;
  459.     FLONUM fcmp;
  460.     int imode;
  461.  
  462.     /* get the two arguments */
  463.     arg1 = xlarg(&args);
  464.     arg2 = xlarg(&args);
  465.     xllastarg(args);
  466.  
  467.     /* do the compare */
  468.     if (stringp(arg1) && stringp(arg2)) {
  469.     icmp = strcmp(getstring(arg1),getstring(arg2));
  470.     imode = TRUE;
  471.     }
  472.     else if (fixp(arg1) && fixp(arg2)) {
  473.     icmp = getfixnum(arg1) - getfixnum(arg2);
  474.     imode = TRUE;
  475.     }
  476.     else if (floatp(arg1) && floatp(arg2)) {
  477.     fcmp = getflonum(arg1) - getflonum(arg2);
  478.     imode = FALSE;
  479.     }
  480.     else if (fixp(arg1) && floatp(arg2)) {
  481.     fcmp = (FLONUM)getfixnum(arg1) - getflonum(arg2);
  482.     imode = FALSE;
  483.     }
  484.     else if (floatp(arg1) && fixp(arg2)) {
  485.     fcmp = getflonum(arg1) - (FLONUM)getfixnum(arg2);
  486.     imode = FALSE;
  487.     }
  488.     else
  489.     xlfail("expecting strings, integers or floats");
  490.  
  491.     /* compute result of the compare */
  492.     if (imode)
  493.     switch (fcn) {
  494.     case '<':    icmp = (icmp < 0); break;
  495.     case 'L':    icmp = (icmp <= 0); break;
  496.     case '=':    icmp = (icmp == 0); break;
  497.     case '#':    icmp = (icmp != 0); break;
  498.     case 'G':    icmp = (icmp >= 0); break;
  499.     case '>':    icmp = (icmp > 0); break;
  500.     }
  501.     else
  502.     switch (fcn) {
  503.     case '<':    icmp = (fcmp < 0.0); break;
  504.     case 'L':    icmp = (fcmp <= 0.0); break;
  505.     case '=':    icmp = (fcmp == 0.0); break;
  506.     case '#':    icmp = (fcmp != 0.0); break;
  507.     case 'G':    icmp = (fcmp >= 0.0); break;
  508.     case '>':    icmp = (fcmp > 0.0); break;
  509.     }
  510.  
  511.     /* return the result */
  512.     return (icmp ? true : NIL);
  513. }
  514.  
  515. /* badiop - bad integer operation */
  516. LOCAL badiop()
  517. {
  518.     xlfail("bad integer operation");
  519. }
  520.  
  521. /* badfop - bad floating point operation */
  522. LOCAL badfop()
  523. {
  524.     xlfail("bad floating point operation");
  525. }
  526. 
  527.